home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gnu / adainc / s-tasren.adb < prev    next >
Text File  |  1996-01-30  |  46KB  |  1,326 lines
  1. -----------------------------------------------------------------------------
  2. --                                                                         --
  3. --                GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                         --
  5. --            S Y S T E M . T A S K I N G . R E N D E Z V O U S            --
  6. --                                                                         --
  7. --                                 B o d y                                 --
  8. --                                                                         --
  9. --                            $Revision: 1.24 $                             --
  10. --                                                                         --
  11. --       Copyright (c) 1991,1992,1993,1994, FSU, All Rights Reserved        --
  12. --                                                                          --
  13. -- GNARL is free software; you can redistribute it  and/or modify it  under --
  14. -- terms  of  the  GNU  Library General Public License  as published by the --
  15. -- Free Software  Foundation;  either version 2, or (at  your  option)  any --
  16. -- later  version.  GNARL is distributed  in the hope that  it will be use- --
  17. -- ful, but but WITHOUT ANY WARRANTY;  without even the implied warranty of --
  18. -- MERCHANTABILITY  or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. -- eral Library Public License  for more details.  You should have received --
  20. -- a  copy of the GNU Library General Public License along with GNARL;  see --
  21. -- file COPYING.LIB.  If not,  write to the  Free Software Foundation,  675 --
  22. -- Mass Ave, Cambridge, MA 02139, USA.                                      --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with System.Task_Primitives; use System.Task_Primitives;
  27.  
  28. with System.Tasking.Abortion;
  29. --  Used for, Abortion.Defer_Abortion,
  30. --            Abortion.Undefer_Abortion,
  31. --            Abortion.Change_Base_Priority
  32.  
  33. with System.Tasking.Queuing; use System.Tasking.Queuing;
  34. --  Used for, Queuing.Enqueue,
  35. --            Queuing.Dequeue,
  36. --            Queuing.Dequeue_Head,
  37. --            Queuing.Count_Waiting,
  38. --            Queuing.Select_Task_Entry_Call
  39.  
  40. with System.Error_Reporting;
  41. --  Used for, Error_Reporting.Assert
  42.  
  43. with System.Tasking.Utilities;
  44. --  Used for, Utilities.ATCB_Ptr,
  45. --            Utilities.ATCB_To_ID,
  46. --            Utilities.ID_To_ATCB,
  47. --            Utilities.Null_PO;
  48. --            Utilities."<",
  49. --            Utilities.">=",
  50. --            Utilities."=",
  51. --            Utilities.Task_Stage
  52. --            Utilities.Accepting_State
  53. --            Utilities.Vulnerable_Complete_Activation
  54. --            Utilities.Abort_To_Level
  55. --            Utilities.Reset_Priority
  56. --            Utilities.Terminate_Alternative
  57.  
  58. with System.Compiler_Exceptions;
  59. --  Used for, Compiler_Exceptions."="
  60. --            Exception_ID
  61. --            Null_Exception
  62. --            Tasking_Error_ID
  63.  
  64. with Unchecked_Conversion;
  65.  
  66. package body System.Tasking.Rendezvous is
  67.  
  68.    function ID_To_ATCB (ID : Task_ID) return Utilities.ATCB_Ptr
  69.      renames Tasking.Utilities.ID_To_ATCB;
  70.  
  71.    function ATCB_To_ID (Ptr : Utilities.ATCB_Ptr) return Task_ID
  72.      renames Utilities.ATCB_To_ID;
  73.  
  74.    procedure Assert (B : Boolean; M : String)
  75.      renames Error_Reporting.Assert;
  76.  
  77.    procedure Defer_Abortion
  78.      renames Abortion.Defer_Abortion;
  79.  
  80.    procedure Undefer_Abortion renames
  81.      Abortion.Undefer_Abortion;
  82.  
  83.    --  Following should be replaced by use type ???
  84.  
  85.    function "<" (L, R : Utilities.Task_Stage) return Boolean
  86.      renames Utilities."<";
  87.  
  88.    function ">=" (L, R : Utilities.Task_Stage) return Boolean
  89.      renames Utilities.">=";
  90.  
  91.    function "=" (L, R : Utilities.Accepting_State) return Boolean
  92.      renames Utilities."=";
  93.  
  94.    function "=" (L, R : Compiler_Exceptions.Exception_ID)
  95.      return Boolean renames Compiler_Exceptions."=";
  96.  
  97.    function Address_To_Protection_Access is new
  98.      Unchecked_Conversion (System.Address, Protection_Access);
  99.  
  100.    function Protection_Access_To_Address is new
  101.      Unchecked_Conversion (Protection_Access, System.Address);
  102.  
  103.    type Select_Treatment is (
  104.      Accept_Alternative_Selected,
  105.      Accept_Alternative_Completed,
  106.      Else_Selected,
  107.      Terminate_Selected,
  108.      Accept_Alternative_Open,
  109.      No_Alternative_Open);
  110.  
  111.    Default_Treatment : constant array (Select_Modes) of Select_Treatment :=
  112.      (Simple_Mode         => No_Alternative_Open,
  113.       Else_Mode           => Else_Selected,
  114.       Terminate_Mode      => Terminate_Selected);
  115.  
  116.    procedure Vulnerable_Cancel_Task_Entry_Call
  117.      (Call                  : Entry_Call_Link;
  118.       Cancel_Was_Successful : out Boolean);
  119.    --  This procedure is used to cancel a task entry call from
  120.    --  within the runtime (including from the interface procedure
  121.    --  Cancel_Protected_Entry_Call).  It assumes that abortion is
  122.    --  deferred, and stores rather than raises any required exceptions.
  123.  
  124.    -----------------------
  125.    -- Local Subprograms --
  126.    -----------------------
  127.  
  128.    procedure Boost_Priority
  129.      (Call     : Entry_Call_Link;
  130.       Acceptor : Utilities.ATCB_Ptr);
  131.    pragma Inline (Boost_Priority);
  132.  
  133.    procedure Test_Call
  134.      (Entry_Call           : in out Entry_Call_Link;
  135.       Rendezvous_Completed : out Boolean);
  136.    --  Test if a rendezvous can be made right away. Returns True if the
  137.    --  rendezvous has occurred (and finished).
  138.    --  Problem: Try not to call this when the acceptor is not accepting.
  139.    --  What does problem mean??? advice??? why??? absolute rule???
  140.  
  141.    function Test_Selective_Wait
  142.      (Acceptor     : Utilities.ATCB_Ptr;
  143.       Open_Accepts : Accept_List_Access;
  144.       Select_Mode  : Select_Modes)
  145.       return         Select_Treatment;
  146.    pragma Inline (Test_Selective_Wait);
  147.    --  Test if there is a call waiting on any entry, and whether any selects
  148.    --  are open. Set Acceptor.Chosen_Index to selected alternative if an
  149.    --  accept alternative can be selected.
  150.  
  151.    procedure Universal_Complete_Rendezvous
  152.      (Ex : Compiler_Exceptions.Exception_ID);
  153.    pragma Inline (Universal_Complete_Rendezvous);
  154.    --  Called by acceptor to wake up caller and optionally propagate exception
  155.  
  156.    procedure Adjust_For_Terminate_Alternative_Call (Acceptor : Task_ID);
  157.    --  Called by caller to wake up the acceptor if it is waiting on
  158.    --  terminate_alternative.
  159.  
  160.    --------------------
  161.    -- Boost_Priority --
  162.    --------------------
  163.  
  164.    procedure Boost_Priority
  165.      (Call     : Entry_Call_Link;
  166.       Acceptor : Utilities.ATCB_Ptr)
  167.    is
  168.       Caller : Utilities.ATCB_Ptr := ID_To_ATCB (Call.Self);
  169.  
  170.    begin
  171.       if Get_Priority (Caller.LL_TCB'Access) >
  172.          Get_Priority (Acceptor.LL_TCB'Access)
  173.       then
  174.          Call.Acceptor_Prev_Priority := Acceptor.Current_Priority;
  175.          Acceptor.Current_Priority := Caller.Current_Priority;
  176.          Set_Priority (Acceptor.LL_TCB'Access, Acceptor.Current_Priority);
  177.       else
  178.          Call.Acceptor_Prev_Priority := Priority_Not_Boosted;
  179.       end if;
  180.    end Boost_Priority;
  181.  
  182.    ---------------
  183.    -- Test_Call --
  184.    ---------------
  185.  
  186.    procedure Test_Call
  187.      (Entry_Call           : in out Entry_Call_Link;
  188.       Rendezvous_Completed : out Boolean)
  189.    is
  190.       Temp_Entry  : Entry_Index;
  191.       TAS_Result  : Boolean;
  192.       Acceptor_ID : Task_ID;
  193.       Acceptor    : Utilities.ATCB_Ptr;
  194.       Caller      : Utilities.ATCB_Ptr := ID_To_ATCB (Entry_Call.Self);
  195.       Error       : Boolean;
  196.    begin
  197.       Acceptor := ID_To_ATCB (Entry_Call.Called_Task);
  198.  
  199.       if Acceptor.Accepting = Utilities.Trivial_Accept then
  200.          Temp_Entry := Entry_Index (Acceptor.Open_Accepts (1).S);
  201.  
  202.          --  Case of rendezvous accepted
  203.  
  204.          if Entry_Call.E = Temp_Entry then
  205.             Acceptor.Accepting := Utilities.Not_Accepting;
  206.             Entry_Call.Acceptor_Prev_Call := Acceptor.Call;
  207.             Acceptor.Call := Entry_Call;
  208.             Entry_Call.Done := True;
  209.             Rendezvous_Completed := True;
  210.             Cond_Signal (Acceptor.Cond); -- Inefficient ???
  211.  
  212.          --  Case of wait for acceptor
  213.  
  214.          else
  215.             Rendezvous_Completed := False;
  216.          end if;
  217.  
  218.       elsif Acceptor.Accepting = Utilities.Not_Accepting then
  219.          if Callable (ATCB_To_ID (Acceptor)) then
  220.             Rendezvous_Completed := False;
  221.             --  Wait for acceptor
  222.          else
  223.             if Entry_Call.Mode /= Asynchronous_Call then
  224.                Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level - 1;
  225.             end if;
  226.  
  227.             Unlock (Acceptor.L);
  228.             Undefer_Abortion;
  229.             raise Tasking_Error;
  230.          end if;
  231.  
  232.       else
  233.          --  Try to do immediate rendezvous
  234.  
  235.          for J in Acceptor.Open_Accepts'Range loop
  236.             Temp_Entry := Entry_Index (Acceptor.Open_Accepts (J).S);
  237.  
  238.             if Entry_Call.E = Temp_Entry then --  do rendezvous
  239.                Test_And_Set (Entry_Call.Call_Claimed'Address, TAS_Result);
  240.  
  241.                if not TAS_Result then
  242.  
  243.                   --  This task has been aborted
  244.  
  245.                   Unlock (Acceptor.L);
  246.                   Write_Lock (Caller.L, Error);
  247.                   Caller.Suspended_Abortably := True;
  248.  
  249.                   loop
  250.                      if Caller.Pending_Action then
  251.                         if Caller.Pending_Priority_Change then
  252.                            Abortion.Change_Base_Priority (Caller);
  253.                         end if;
  254.  
  255.                         exit when
  256.                            Caller.Pending_ATC_Level < Caller.ATC_Nesting_Level;
  257.                         Caller.Pending_Action := False;
  258.                      end if;
  259.                      Cond_Wait (Caller.Rend_Cond, Caller.L);
  260.                   end loop;
  261.  
  262.                   Caller.Suspended_Abortably := False;
  263.                   Unlock (Caller.L);
  264.                   Write_Lock (Acceptor.L, Error);
  265.  
  266.                end if;
  267.  
  268.                Acceptor.Accepting := Utilities.Not_Accepting;
  269.  
  270.                if Acceptor.Open_Accepts (J).Null_Body then
  271.                   Entry_Call.Done := True;
  272.                   Acceptor.Chosen_Index := J;
  273.                   Cond_Signal (Acceptor.Cond);
  274.                else
  275.                   Entry_Call.Acceptor_Prev_Call := Acceptor.Call;
  276.                   Acceptor.Call := Entry_Call;
  277.                   Acceptor.Chosen_Index := J;
  278.                   Boost_Priority (Entry_Call, Acceptor);
  279.                   Cond_Signal (Acceptor.Cond);
  280.  
  281.                   --  This needs to be protected by the caller's mutex, not
  282.                   --  the acceptor's.  Otherwise, there is a risk of loosing a
  283.                   --  signal.  This is dumb code, and probably could be
  284.                   --  fixed to some extent by getting rid of Test_Call. ???
  285.  
  286.                   Unlock (Acceptor.L);
  287.                   Write_Lock (Caller.L, Error);
  288.  
  289.                   while not Entry_Call.Done loop
  290.                      Cond_Wait (Caller.Rend_Cond, Caller.L);
  291.                   end loop;
  292.  
  293.                   Unlock (Caller.L);
  294.                   Write_Lock (Acceptor.L, Error);
  295.                end if;
  296.  
  297.                Rendezvous_Completed := True;
  298.                return;
  299.             end if;
  300.          end loop;
  301.  
  302.          Rendezvous_Completed := False;
  303.       end if;
  304.    end Test_Call;
  305.  
  306.    ---------------------------------------
  307.    -- Vulnerable_Cancel_Task_Entry_Call --
  308.    ---------------------------------------
  309.  
  310.    procedure Vulnerable_Cancel_Task_Entry_Call
  311.      (Call                  : Entry_Call_Link;
  312.       Cancel_Was_Successful : out Boolean)
  313.    is
  314.       TAS_Result : Boolean;
  315.       Caller     : Utilities.ATCB_Ptr := ID_To_ATCB (Call.Self);
  316.       Acceptor   : Utilities.ATCB_Ptr := ID_To_ATCB (Call.Called_Task);
  317.       Error      : Boolean;
  318.  
  319.    begin
  320.       Cancel_Was_Successful := False;
  321.       Test_And_Set (Call.Call_Claimed'Address, TAS_Result);
  322.  
  323.       if TAS_Result then
  324.          if not Call.Done then
  325.  
  326.          --  We should be able to check this flag at this point; we have
  327.          --  claimed the call, so no one will be able to service this call,
  328.          --  so no one else should be able to change the Call.Done flag.
  329.  
  330.             Write_Lock (Acceptor.L, Error);
  331.             if Onqueue (Call) then
  332.                Dequeue (
  333.                   Acceptor.Entry_Queues (Task_Entry_Index (Call.E)),
  334.                   Call);
  335.             end if;
  336.             Unlock (Acceptor.L);
  337.             Cancel_Was_Successful := True;
  338.  
  339.             --  Note: this will indicate failure to cancel if the acceptor has
  340.             --  canceled the call due to completion.  Of course, we are going
  341.             --  to raise an exception in that case, so I think that this is
  342.             --  OK; the flag retuned to the application code should never be
  343.             --  used.
  344.          end if;
  345.  
  346.       else
  347.          Write_Lock (Caller.L, Error);
  348.  
  349.          while not Call.Done loop
  350.             Cond_Wait (Caller.Rend_Cond, Caller.L);
  351.          end loop;
  352.  
  353.          Unlock (Caller.L);
  354.       end if;
  355.  
  356.       Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level - 1;
  357.  
  358.       Write_Lock (Caller.L, Error);
  359.  
  360.       if Caller.Pending_ATC_Level = Caller.ATC_Nesting_Level then
  361.          Caller.Pending_ATC_Level := ATC_Level_Infinity;
  362.          Caller.Aborting := False;
  363.       end if;
  364.  
  365.       Unlock (Caller.L);
  366.  
  367.       --  If we have reached the desired ATC nesting level, reset the
  368.       --  requested level to effective infinity, to allow further calls.
  369.  
  370.       Caller.Exception_To_Raise := Call.Exception_To_Raise;
  371.  
  372.    end Vulnerable_Cancel_Task_Entry_Call;
  373.  
  374.    -------------------------------------------
  375.    -- Adjust_For_Terminate_Alternative_Call --
  376.    -------------------------------------------
  377.  
  378.    procedure Adjust_For_Terminate_Alternative_Call (Acceptor : Task_ID) is
  379.       Acceptor_ATCB : Utilities.ATCB_Ptr := ID_To_ATCB (Acceptor);
  380.       P             : Utilities.ATCB_Ptr;
  381.       Error         : boolean;
  382.    begin
  383.       Write_Lock (Acceptor_ATCB.L, Error);
  384.  
  385.       if Acceptor_ATCB.Terminate_Alternative then
  386.          Acceptor_ATCB.Stage := Utilities.Active;
  387.          Acceptor_ATCB.Awake_Count := Acceptor_ATCB.Awake_Count + 1;
  388.  
  389.          --  At this point, T.Awake_Count and P.Awaited_Dependent_Count could
  390.          --  be out of synchronization.  However, we know that
  391.          --  P.Awaited_Dependent_Count cannot be zero, and cannot go to zero,
  392.          --  since some other dependent must have just called us.  There should
  393.          --  therefore be no danger of the parent terminating before we
  394.          --  increment P.Awaited_Dependent_Count below.
  395.  
  396.          if Acceptor_ATCB.Awake_Count = 1 then
  397.             Unlock (Acceptor_ATCB.L);
  398.  
  399.             if Acceptor_ATCB.Pending_ATC_Level <
  400.               Acceptor_ATCB.ATC_Nesting_Level then
  401.                Abortion.Undefer_Abortion;
  402.                Error_Reporting.Assert
  403.                   (False, "Continuing after being aborted!");
  404.             end if;
  405.  
  406.             P := Acceptor_ATCB.Parent;
  407.             Write_Lock (P.L, Error);
  408.  
  409.             if P.Awake_Count /= 0 then
  410.                P.Awake_Count := P.Awake_Count + 1;
  411.  
  412.             else
  413.                Unlock (P.L);
  414.                Utilities.Abort_To_Level (Acceptor, 0);
  415.                Abortion.Undefer_Abortion;
  416.                Error_Reporting.Assert
  417.                  (False, "Continuing after being aborted!");
  418.             end if;
  419.  
  420.             --  Conservative checks which should only matter when an interrupt
  421.             --  entry was chosen. In this case, the current task completes if
  422.             --  the parent has already been signaled that all children have
  423.             --  terminated.
  424.  
  425.             if Acceptor_ATCB.Master_of_Task = P.Master_Within then
  426.                if P.Awaited_Dependent_Count /= 0 then
  427.                   P.Awaited_Dependent_Count := P.Awaited_Dependent_Count + 1;
  428.  
  429.                elsif P.Stage = Utilities.Await_Dependents then
  430.                   Unlock (P.L);
  431.                   Utilities.Abort_To_Level (Acceptor, 0);
  432.                   Abortion.Undefer_Abortion;
  433.                   Error_Reporting.Assert (
  434.                     False, "Continuing after being aborted!");
  435.                end if;
  436.             end if;
  437.  
  438.             Unlock (P.L);
  439.  
  440.          else
  441.             Unlock (Acceptor_ATCB.L);
  442.  
  443.             if Acceptor_ATCB.Pending_ATC_Level <
  444.               Acceptor_ATCB.ATC_Nesting_Level then
  445.                Abortion.Undefer_Abortion;
  446.                Error_Reporting.Assert
  447.                  (False, "Continuing after being aborted!");
  448.             end if;
  449.          end if;
  450.  
  451.          Write_Lock (Acceptor_ATCB.L, Error);
  452.  
  453.          Acceptor_ATCB.Terminate_Alternative := false;
  454.          --  Need to set this flag off in order not to make subsequent calls
  455.          --  to be treated to calls to Select With Terminate Alternative.
  456.  
  457.       end if;
  458.       Unlock (Acceptor_ATCB.L);
  459.  
  460.    end Adjust_For_Terminate_Alternative_Call;
  461.  
  462.  
  463.    -----------------
  464.    -- Call_Simple --
  465.    -----------------
  466.  
  467.    procedure Call_Simple
  468.      (Acceptor  : Task_ID;
  469.       E         : Task_Entry_Index;
  470.       Uninterpreted_Data : System.Address)
  471.    is
  472.       Caller : constant Utilities.ATCB_Ptr := ID_To_ATCB (Self);
  473.  
  474.       Acceptor_ATCB         : Utilities.ATCB_Ptr := ID_To_ATCB (Acceptor);
  475.       Rendezvous_Completed  : Boolean;
  476.       Level                 : ATC_Level;
  477.       Entry_Call            : Entry_Call_Link;
  478.       Cancel_Was_Successful : Boolean;
  479.       Error                 : Boolean;
  480.    begin
  481.       Defer_Abortion;
  482.       Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level + 1;
  483.       Level := Caller.ATC_Nesting_Level;
  484.  
  485.       Entry_Call := Caller.Entry_Calls (Level)'Access;
  486.  
  487.       Entry_Call.Next := null;
  488.       Entry_Call.Call_Claimed := False;
  489.       Entry_Call.Mode := Simple_Call;
  490.       Entry_Call.Abortable := True;
  491.       Entry_Call.Done := False;
  492.       Entry_Call.E := Entry_Index (E);
  493.       Entry_Call.Prio := Caller.Current_Priority;
  494.       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
  495.       Entry_Call.Called_Task := Acceptor;
  496.       Entry_Call.Exception_To_Raise := Compiler_Exceptions.Null_Exception;
  497.  
  498. --      if Acceptor_ATCB.Accepting = Utilities.Not_Accepting and then
  499. --        not Callable (Acceptor) then
  500. --         --  Acceptor must have gone beyond the complete stage.
  501. --         --  This situation may occur when the acceptor and caller are
  502. --         --  declared in different context. (ex) Interrupt Handler.
  503. --         --  This is the case where the acceptor is completed before
  504. --         --  the entry call is made. In such a case, just cancel the
  505. --         --  call.
  506. --         Unlock (Acceptor_ATCB.L);
  507. --         Vulnerable_Cancel_Task_Entry_Call
  508. --           (Entry_Call, Cancel_Was_Successful);
  509. --         Undefer_Abortion;
  510. --         return;
  511. --      end if;
  512.  
  513.  
  514.       --  Note: the caller will undefer abortion on return (see WARNING above)
  515.  
  516.       Adjust_For_Terminate_Alternative_Call (Acceptor);
  517.  
  518.       Write_Lock (Acceptor_ATCB.L, Error);
  519.  
  520.       Test_Call (Entry_Call, Rendezvous_Completed);
  521.  
  522.       if not Rendezvous_Completed then
  523.          Enqueue (Acceptor_ATCB.Entry_Queues (E), Entry_Call);
  524.          Unlock (Acceptor_ATCB.L);
  525.          Write_Lock (Caller.L, Error);
  526.          Caller.Suspended_Abortably := True;
  527.  
  528.          while not Entry_Call.Done loop
  529.             if Caller.Pending_Action then
  530.                if Caller.Pending_Priority_Change then
  531.                   Abortion.Change_Base_Priority (Caller);
  532.                   --  requeue call at new priority
  533.                   Unlock (Caller.L);
  534.                   Write_Lock (Acceptor_ATCB.L, Error);
  535.                   if Onqueue (Entry_Call) then  --  Dequeued by acceptor?
  536.                      Dequeue (Acceptor_ATCB.Entry_Queues (E), Entry_Call);
  537.                      Enqueue (Acceptor_ATCB.Entry_Queues (E), Entry_Call);
  538.                   end if;
  539.                   Unlock (Acceptor_ATCB.L);
  540.                   Write_Lock (Caller.L, Error);
  541.                end if;
  542.  
  543.                exit when
  544.                   Caller.Pending_ATC_Level < Caller.ATC_Nesting_Level and then
  545.                   not Entry_Call.Call_Claimed;
  546.             end if;
  547.             Cond_Wait (Caller.Rend_Cond, Caller.L);
  548.          end loop;
  549.  
  550.          Caller.Suspended_Abortably := False;
  551.          Unlock (Caller.L);
  552.  
  553.       else
  554.          Unlock (Acceptor_ATCB.L);
  555.       end if;
  556.  
  557.       --  NOTICE:
  558.       --  There is a distinction made between asynchronous calls and the rest:
  559.       --  The asynchronous calls are always cleaned up by
  560.       --  Cancel_Task_Entry_Call, but the others get cleaned up by
  561.       --  Task_Entry_Call or its equivalent.
  562.       --  Complete no longer does a decrement, so who does if this task is
  563.       --  aborted at this point?  The decrement should take
  564.       --  place before undeferring abortion, and that this should include
  565.       --  taking the call off any queue it might be on.
  566.       --  Problem: What if it is claimed in the meantime by an acceptor?  The
  567.       --  test for Call_Claimed in the wait loop is really vulnerable to race
  568.       --  conditions on this point.  We can't get out of the loop until
  569.       --  Call_Claimed is false, but there is nothing to keep it from
  570.       --  staying false.  By the time we get here, rendezvous could be in
  571.       --  progress.  The only solution is to claim the call here in order
  572.       --  to cancel it.  However, what do we do if we loose?  Wait again?
  573.       --  I think so.  I also think that that works: wait until done or
  574.       --  aborted; if aborted, attempt to cancel the call; if that fails, wait
  575.       --  until the call (now well and truly started) completes, without
  576.       --  benefit of Suspended_Abortably.
  577.       --  Problem: The acceptor might also claim the call on completion, to
  578.       --  cancel it.  In that case, it has already awakened us, and won't do it
  579.       --  again.
  580.       --  I think this is OK.  Close_Entries already pretends that the
  581.       --  call has been completed, and has already set the exception at that
  582.       --  point.
  583.  
  584.       Vulnerable_Cancel_Task_Entry_Call (Entry_Call, Cancel_Was_Successful);
  585.       Undefer_Abortion;
  586.  
  587.       Assert (Caller.Pending_ATC_Level >= Caller.ATC_Nesting_Level,
  588.         "Continuing after aborting self!");
  589.  
  590.       Utilities.Check_Exception;
  591.    end Call_Simple;
  592.  
  593.    ----------------------------
  594.    -- Cancel_Task_Entry_Call --
  595.    ----------------------------
  596.  
  597.    procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is
  598.       Caller   : Utilities.ATCB_Ptr := ID_To_ATCB (Self);
  599.       Call     : Entry_Call_Link;
  600.       Acceptor : Utilities.ATCB_Ptr;
  601.  
  602.    begin
  603.       Assert (Caller.ATC_Nesting_Level > ATC_Level_Base'First,
  604.         "Attempt to cancel nonexistant task entry call.");
  605.  
  606.       Call := Caller.Entry_Calls (Caller.ATC_Nesting_Level)'Access;
  607.  
  608.       Assert (Call.Mode = Asynchronous_Call,
  609.         "Attempt to perform ATC on a non-asynchronous task entry call");
  610.       Assert (Address_To_Protection_Access (Call.Called_PO) =
  611.           Utilities.Null_PO,
  612.         "Attempt to use Cancel_Task_Entry_Call on protected entry call.");
  613.  
  614.       Acceptor := ID_To_ATCB (Call.Called_Task);
  615.       Defer_Abortion;
  616.       Vulnerable_Cancel_Task_Entry_Call (Call, Cancelled);
  617.       Undefer_Abortion;
  618.       Utilities.Check_Exception;
  619.    end Cancel_Task_Entry_Call;
  620.  
  621.    ------------------------
  622.    -- Requeue_Task_Entry --
  623.    ------------------------
  624.  
  625.    procedure Requeue_Task_Entry
  626.      (Acceptor   : Task_ID;
  627.       E          : Task_Entry_Index;
  628.       With_Abort : Boolean)
  629.    is
  630.       Old_Acceptor  : Utilities.ATCB_Ptr := ID_To_ATCB (Self);
  631.       Entry_Call    : Entry_Call_Link;
  632.       Acceptor_ATCB : Utilities.ATCB_Ptr := ID_To_ATCB (Acceptor);
  633.       Error         : Boolean;
  634.  
  635.    begin
  636.       Write_Lock (Old_Acceptor.L, Error);
  637.       Entry_Call := Old_Acceptor.Call;
  638.       Old_Acceptor.Call := null;
  639.       Unlock (Old_Acceptor.L);
  640.  
  641.       Entry_Call.Abortable := With_Abort;
  642.       Entry_Call.E := Entry_Index (E);
  643.  
  644.       if With_Abort then
  645.          Entry_Call.Call_Claimed := False;
  646.       end if;
  647.  
  648.       Write_Lock (Acceptor_ATCB.L, Error);
  649.       Enqueue (Acceptor_ATCB.Entry_Queues (E), Entry_Call);
  650.       Unlock (Acceptor_ATCB.L);
  651.    end Requeue_Task_Entry;
  652.  
  653.    -------------------------------------
  654.    -- Requeue_Protected_To_Task_Entry --
  655.    -------------------------------------
  656.  
  657.    procedure Requeue_Protected_To_Task_Entry
  658.      (Object     : Protection_Access;
  659.       Acceptor   : Task_ID;
  660.       E          : Task_Entry_Index;
  661.       With_Abort : Boolean)
  662.    is
  663.       Old_Acceptor  : Utilities.ATCB_Ptr := ID_To_ATCB (Self);
  664.       Entry_Call    : Entry_Call_Link;
  665.       Acceptor_ATCB : Utilities.ATCB_Ptr := ID_To_ATCB (Acceptor);
  666.       Error         : Boolean;
  667.  
  668.    begin
  669.       Object.Call_In_Progress.Abortable := With_Abort;
  670.       Object.Call_In_Progress.E := Entry_Index (E);
  671.  
  672.       if With_Abort then
  673.          Object.Call_In_Progress.Call_Claimed := False;
  674.       end if;
  675.  
  676.       Write_Lock (Acceptor_ATCB.L, Error);
  677.       Enqueue (Acceptor_ATCB.Entry_Queues (E), Object.Call_In_Progress);
  678.       Unlock (Acceptor_ATCB.L);
  679.    end Requeue_Protected_To_Task_Entry;
  680.  
  681.    ---------------------
  682.    -- Task_Entry_Call --
  683.    ---------------------
  684.  
  685.    procedure Task_Entry_Call
  686.      (Acceptor              : Task_ID;
  687.       E                     : Task_Entry_Index;
  688.       Uninterpreted_Data             : System.Address;
  689.       Mode                  : Call_Modes;
  690.       Rendezvous_Successful : out Boolean)
  691.    is
  692.       Caller        : constant Utilities.ATCB_Ptr := ID_To_ATCB (Self);
  693.       Acceptor_ATCB : Utilities.ATCB_Ptr := ID_To_ATCB (Acceptor);
  694.  
  695.       Rendezvous_Completed  : Boolean;
  696.       Entry_Call            : Entry_Call_Link;
  697.       Cancel_Was_Successful : Boolean;
  698.       Error                 : Boolean;
  699.  
  700.    begin
  701.       --  Simple call
  702.  
  703.       if Mode = Simple_Call then
  704.          Call_Simple (Acceptor, E, Uninterpreted_Data);
  705.          Rendezvous_Successful := True;
  706.          return;
  707.  
  708.       --  Conditional call
  709.  
  710.       elsif Mode = Conditional_Call then
  711.          Defer_Abortion;
  712.          Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level + 1;
  713.  
  714.          Entry_Call := Caller.Entry_Calls (Caller.ATC_Nesting_Level)'Access;
  715.  
  716.          Entry_Call.Next := null;
  717.          Entry_Call.Call_Claimed := False;
  718.          Entry_Call.Mode := Mode;
  719.          Entry_Call.Abortable := True;
  720.          Entry_Call.Done := False;
  721.          Entry_Call.E := Entry_Index (E);
  722.          Entry_Call.Prio := Caller.Current_Priority;
  723.          Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
  724.          Entry_Call.Called_Task := Acceptor;
  725.          Entry_Call.Exception_To_Raise := Compiler_Exceptions.Null_Exception;
  726.  
  727.          Adjust_For_Terminate_Alternative_Call (Acceptor);
  728.  
  729.          Write_Lock (Acceptor_ATCB.L, Error);
  730.          Test_Call (Entry_Call, Rendezvous_Completed);
  731.          Unlock (Acceptor_ATCB.L);
  732.  
  733.          Vulnerable_Cancel_Task_Entry_Call (Entry_Call, Cancel_Was_Successful);
  734.  
  735.          Undefer_Abortion;
  736.  
  737.          Assert (Caller.Pending_ATC_Level >= Caller.ATC_Nesting_Level,
  738.            "Continuing after aborting self!");
  739.  
  740.          Utilities.Check_Exception;
  741.          Rendezvous_Successful := Entry_Call.Done;
  742.          return;
  743.  
  744.       --  Asynchronous call
  745.  
  746.       else
  747.          Defer_Abortion;
  748.          Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level + 1;
  749.  
  750.          Entry_Call := Caller.Entry_Calls (Caller.ATC_Nesting_Level)'Access;
  751.  
  752.          Entry_Call.Next := null;
  753.          Entry_Call.Call_Claimed := False;
  754.          Entry_Call.Mode := Mode;
  755.          Entry_Call.Abortable := True;
  756.          Entry_Call.Done := False;
  757.          Entry_Call.E := Entry_Index (E);
  758.          Entry_Call.Prio := Caller.Current_Priority;
  759.          Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
  760.          Entry_Call.Called_Task := Acceptor;
  761.          Entry_Call.Called_PO :=
  762.              Protection_Access_To_Address (Utilities.Null_PO);
  763.          Entry_Call.Exception_To_Raise := Compiler_Exceptions.Null_Exception;
  764.  
  765.          Adjust_For_Terminate_Alternative_Call (Acceptor);
  766.  
  767.          Write_Lock (Acceptor_ATCB.L, Error);
  768.          Test_Call (Entry_Call, Rendezvous_Completed);
  769.  
  770.          if not Rendezvous_Completed then
  771.             Enqueue (Acceptor_ATCB.Entry_Queues (E), Entry_Call);
  772.          end if;
  773.  
  774.          Unlock (Acceptor_ATCB.L);
  775.          Undefer_Abortion;
  776.          Rendezvous_Successful := Entry_Call.Done;
  777.  
  778.          --  Amazingly, this seems to be all the work that is needed.
  779.  
  780.          --  Asynchronous calls are set up so that they are always explicitly
  781.          --  canceled in in the compiled code. It might be worth considering
  782.          --  unifying the various calls, and explitely cancelling all of them.
  783.          --  This is not very efficiant, unfortunately.  Perhaps this call
  784.          --  should unify them, with other calls for optimization?  Then who
  785.          --  would want to use this call???
  786.  
  787.       end if;
  788.    end Task_Entry_Call;
  789.  
  790.    -----------------
  791.    -- Accept_Call --
  792.    -----------------
  793.  
  794.    procedure Accept_Call
  795.      (E         : Task_Entry_Index;
  796.       Uninterpreted_Data : out System.Address)
  797.    is
  798.       Acceptor     : constant Utilities.ATCB_Ptr := ID_To_ATCB (Self);
  799.       Caller       : Utilities.ATCB_Ptr := null;
  800.       TAS_Result   : Boolean;
  801.       Open_Accepts : aliased Accept_List (1 .. 1);
  802.       Entry_Call   : Entry_Call_Link;
  803.       Error        : Boolean;
  804.  
  805.    begin
  806.       Defer_Abortion;
  807.       Write_Lock (Acceptor.L, Error);
  808.  
  809.       --  If someone is completing this task, it must be because they plan
  810.       --  to abort it.  This task should not try to access its pending entry
  811.       --  calls or queues in this case, as they are being emptied.  Wait for
  812.       --  abortion to kill us.
  813.  
  814.       if Acceptor.Stage >= Utilities.Completing then
  815.  
  816.          loop
  817.             if Acceptor.Pending_Action then
  818.                if Acceptor.Pending_Priority_Change then
  819.                   Abortion.Change_Base_Priority (Acceptor);
  820.                end if;
  821.  
  822.                exit when
  823.                   Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level;
  824.                Acceptor.Pending_Action := False;
  825.             end if;
  826.             Cond_Wait (Acceptor.Cond, Acceptor.L);
  827.          end loop;
  828.  
  829.          Unlock (Acceptor.L);
  830.          Undefer_Abortion;
  831.          Assert (False, "Continuing execution after being aborted.");
  832.       end if;
  833.  
  834.       loop
  835.          Dequeue_Head (Acceptor.Entry_Queues (E), Entry_Call);
  836.  
  837.          if Entry_Call /= null then
  838.             Test_And_Set (Entry_Call.Call_Claimed'Address, TAS_Result);
  839.             exit when TAS_Result;
  840.  
  841.             --  TAS_Result = False only when the caller is already aborted or
  842.             --  timed out; in that case, go on to the next caller on the queue
  843.          else
  844.             exit;
  845.          end if;
  846.       end loop;
  847.  
  848.       if Entry_Call /= null then
  849.          Caller := ID_To_ATCB (Entry_Call.Self);
  850.          Boost_Priority (Entry_Call, Acceptor);
  851.          Entry_Call.Acceptor_Prev_Call := Acceptor.Call;
  852.          Acceptor.Call := Entry_Call;
  853.          Uninterpreted_Data := Entry_Call.Uninterpreted_Data;
  854.  
  855.       else
  856.          --  Wait for a caller
  857.  
  858.          Open_Accepts (1).Null_Body := false;
  859.          Open_Accepts (1).S := E;
  860.          Acceptor.Open_Accepts := Open_Accepts'Access;
  861.  
  862.          Acceptor.Accepting := Utilities.Simple_Accept;
  863.  
  864.          --  Wait for normal call
  865.  
  866.          Acceptor.Suspended_Abortably := True;
  867.  
  868.          while Acceptor.Accepting /= Utilities.Not_Accepting loop
  869.             if Acceptor.Pending_Action then
  870.                if Acceptor.Pending_Priority_Change then
  871.                   Abortion.Change_Base_Priority (Acceptor);
  872.                end if;
  873.  
  874.                exit when
  875.                   Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level;
  876.                Acceptor.Pending_Action := False;
  877.             end if;
  878.             Cond_Wait (Acceptor.Cond, Acceptor.L);
  879.          end loop;
  880.  
  881.          Acceptor.Suspended_Abortably := False;
  882.  
  883.          if Acceptor.Pending_ATC_Level >= Acceptor.ATC_Nesting_Level then
  884.             Caller := ID_To_ATCB (Acceptor.Call.Self);
  885.             Uninterpreted_Data :=
  886.               Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data;
  887.          end if;
  888.  
  889.          --  If this task has been aborted, skip the Uninterpreted_Data load
  890.          --  (Caller will not be reliable) and fall through to
  891.          --  Undefer_Abortion which will allow the task to be killed.
  892.       end if;
  893.  
  894.       --  At this point, the call has been claimed, either by the acceptor
  895.       --  or by the caller on behalf of the acceptor.
  896.  
  897.       --  Acceptor.Call should already be updated by the Caller
  898.  
  899.       Unlock (Acceptor.L);
  900.       Undefer_Abortion;
  901.  
  902.       --  Start rendezvous
  903.    end Accept_Call;
  904.  
  905.    --------------------
  906.    -- Accept_Trivial --
  907.    --------------------
  908.  
  909.    procedure Accept_Trivial (E : Task_Entry_Index) is
  910.       Acceptor     : constant Utilities.ATCB_Ptr := ID_To_ATCB (Self);
  911.       Caller       : Utilities.ATCB_Ptr := null;
  912.       TAS_Result   : Boolean;
  913.       Open_Accepts : aliased Accept_List (1 .. 1);
  914.       Entry_Call   : Entry_Call_Link;
  915.       Error        : Boolean;
  916.  
  917.    begin
  918.       Defer_Abortion;
  919.       Write_Lock (Acceptor.L, Error);
  920.  
  921.       --  If someone is completing this task, it must be because they plan
  922.       --  to abort it.  This task should not try to access its pending entry
  923.       --  calls or queues in this case, as they are being emptied.  Wait for
  924.       --  abortion to kill us.
  925.  
  926.       if Acceptor.Stage >= Utilities.Completing then
  927.  
  928.          loop
  929.             if Acceptor.Pending_Action then
  930.                if Acceptor.Pending_Priority_Change then
  931.                   Abortion.Change_Base_Priority (Acceptor);
  932.                end if;
  933.  
  934.                exit when
  935.                   Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level;
  936.                Acceptor.Pending_Action := False;
  937.             end if;
  938.             Cond_Wait (Acceptor.Cond, Acceptor.L);
  939.          end loop;
  940.  
  941.          Unlock (Acceptor.L);
  942.          Undefer_Abortion;
  943.          Assert (False, "Continuing execution after being aborted.");
  944.       end if;
  945.  
  946.       loop
  947.          Dequeue_Head (Acceptor.Entry_Queues (E), Entry_Call);
  948.  
  949.          if Entry_Call = null then
  950.  
  951.             --  Need to wait for call
  952.  
  953.             Open_Accepts (1).Null_Body := False;
  954.             Open_Accepts (1).S := E;
  955.             Acceptor.Open_Accepts := Open_Accepts'Access;
  956.  
  957.             Acceptor.Accepting := Utilities.Trivial_Accept;
  958.  
  959.             --  Wait for normal entry call
  960.  
  961.             Acceptor.Suspended_Abortably := True;
  962.  
  963.             while Acceptor.Accepting /= Utilities.Not_Accepting loop
  964.                if Acceptor.Pending_Action then
  965.                   if Acceptor.Pending_Priority_Change then
  966.                      Abortion.Change_Base_Priority (Acceptor);
  967.                   end if;
  968.  
  969.                   exit when
  970.                      Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level;
  971.                   Acceptor.Pending_Action := False;
  972.                end if;
  973.                Cond_Wait (Acceptor.Cond, Acceptor.L);
  974.             end loop;
  975.  
  976.  
  977.             if Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level then
  978.                Unlock (Acceptor.L);
  979.                Undefer_Abortion;
  980.                Assert (False, "Continuing after being aborted!");
  981.             else
  982.                Acceptor.Suspended_Abortably := False;
  983.                Entry_Call := Acceptor.Call;
  984.                Acceptor.Call := Entry_Call.Acceptor_Prev_Call;
  985.                Caller := ID_To_ATCB (Entry_Call.Self);
  986.  
  987.                if Entry_Call.Mode = Asynchronous_Call then
  988.                   Utilities.Abort_To_Level
  989.                    (ATCB_To_ID (Caller),
  990.                     Entry_Call.Level - 1);
  991.                end if;
  992.  
  993.                Unlock (Acceptor.L);
  994.             end if;
  995.  
  996.             exit;
  997.          end if;
  998.  
  999.          Test_And_Set (Entry_Call.Call_Claimed'Address, TAS_Result);
  1000.  
  1001.          if TAS_Result then
  1002.  
  1003.             --  Caller is waiting; there is no accept body
  1004.  
  1005.             Caller := ID_To_ATCB (Entry_Call.Self);
  1006.             Unlock (Acceptor.L);
  1007.             Write_Lock (Caller.L, Error);
  1008.             Entry_Call.Done := True;
  1009.  
  1010.             --  Done with mutex locked to make sure that signal is not lost.
  1011.  
  1012.             Unlock (Caller.L);
  1013.             Entry_Call.Call_Claimed := False;
  1014.  
  1015.             if Entry_Call.Mode = Asynchronous_Call then
  1016.                Utilities.Abort_To_Level (
  1017.                  ATCB_To_ID (Caller), Entry_Call.Level - 1);
  1018.             else
  1019.                Cond_Signal (Caller.Rend_Cond);
  1020.             end if;
  1021.  
  1022.             exit;
  1023.          end if;
  1024.  
  1025.          --  TAS_Result = False only when the caller is already aborted or has
  1026.          --  timed out; in that case, we go on to the next caller on the queue
  1027.  
  1028.       end loop;
  1029.  
  1030.       Undefer_Abortion;
  1031.    end Accept_Trivial;
  1032.  
  1033.    -----------------------------------
  1034.    -- Universal_Complete_Rendezvous --
  1035.    -----------------------------------
  1036.  
  1037.    procedure Universal_Complete_Rendezvous
  1038.      (Ex : Compiler_Exceptions.Exception_ID)
  1039.    is
  1040.       Acceptor      : constant Utilities.ATCB_Ptr := ID_To_ATCB (Self);
  1041.       Caller        : Utilities.ATCB_Ptr;
  1042.       Call          : Entry_Call_Link;
  1043.       Prev_Priority : Rendezvous_Priority;
  1044.       Error         : Boolean;
  1045.  
  1046.    begin
  1047.       Defer_Abortion;
  1048.       Call := Acceptor.Call;
  1049.       Acceptor.Call := Call.Acceptor_Prev_Call;
  1050.       Prev_Priority := Call.Acceptor_Prev_Priority;
  1051.       Call.Exception_To_Raise := Ex;
  1052.       Caller := ID_To_ATCB (Call.Self);
  1053.       Call.Call_Claimed := False;
  1054.       Write_Lock (Caller.L, Error);
  1055.       Call.Done := True;
  1056.       Unlock (Caller.L);
  1057.  
  1058.       if Call.Mode = Asynchronous_Call then
  1059.          Utilities.Abort_To_Level (ATCB_To_ID (Caller), Call.Level - 1);
  1060.       else
  1061.          Cond_Signal (Caller.Rend_Cond);
  1062.       end if;
  1063.  
  1064.       Utilities.Reset_Priority (Prev_Priority, ATCB_To_ID (Acceptor));
  1065.  
  1066.       Acceptor.Exception_To_Raise := Ex;
  1067.  
  1068.       --  Save the exception for Complete_Rendezvous.
  1069.  
  1070.       Undefer_Abortion;
  1071.    end Universal_Complete_Rendezvous;
  1072.  
  1073.    -------------------------
  1074.    -- Complete_Rendezvous --
  1075.    -------------------------
  1076.  
  1077.    procedure Complete_Rendezvous is
  1078.    begin
  1079.       Universal_Complete_Rendezvous (Compiler_Exceptions.Null_Exception);
  1080.    end Complete_Rendezvous;
  1081.  
  1082.    -------------------------------------
  1083.    -- Exceptional_Complete_Rendezvous --
  1084.    -------------------------------------
  1085.  
  1086.    procedure Exceptional_Complete_Rendezvous
  1087.      (Ex : Compiler_Exceptions.Exception_ID)
  1088.    is
  1089.    begin
  1090.       Universal_Complete_Rendezvous (Ex);
  1091.    end Exceptional_Complete_Rendezvous;
  1092.  
  1093.    -------------------------
  1094.    -- Test_Selective_Wait --
  1095.    -------------------------
  1096.  
  1097.  
  1098.    function Test_Selective_Wait
  1099.      (Acceptor     : Utilities.ATCB_Ptr;
  1100.       Open_Accepts : Accept_List_Access;
  1101.       Select_Mode  : Select_Modes) return Select_Treatment
  1102.    is
  1103.       Temp_Entry : Task_Entry_Index;
  1104.       TAS_Result : Boolean;
  1105.       Treatment  : Select_Treatment;
  1106.       Entry_Call : Entry_Call_Link;
  1107.       Caller     : Utilities.ATCB_Ptr;
  1108.       Error      : Boolean;
  1109.       Selection  : Select_Index;
  1110.    begin
  1111.       Treatment := Default_Treatment (Select_Mode);
  1112.       Acceptor.Chosen_Index := No_Rendezvous;
  1113.  
  1114.       Select_Task_Entry_Call (Acceptor, Open_Accepts, Entry_Call, Selection);
  1115.  
  1116.       if Entry_Call /= null then
  1117.          if Open_Accepts (Selection).Null_Body then
  1118.             Caller := ID_To_ATCB (Entry_Call.Self);
  1119.             Entry_Call.Call_Claimed := False;
  1120.             Write_Lock (Caller.L, Error);
  1121.             Entry_Call.Done := True;
  1122.             Unlock (Caller.L);
  1123.             if Entry_Call.Mode = Asynchronous_Call then
  1124.                Utilities.Abort_To_Level (
  1125.                ATCB_To_ID (Caller),
  1126.                Entry_Call.Level - 1);
  1127.             else
  1128.                Cond_Signal (Caller.Rend_Cond);
  1129.             end if;
  1130.             Treatment := Accept_Alternative_Completed;
  1131.          else
  1132.             Boost_Priority (Entry_Call, Acceptor);
  1133.             Entry_Call.Acceptor_Prev_Call := Acceptor.Call;
  1134.             Acceptor.Call := Entry_Call;
  1135.             Treatment := Accept_Alternative_Selected;
  1136.          end if;
  1137.          Acceptor.Chosen_Index := Selection;
  1138.       elsif Treatment = No_Alternative_Open then
  1139.          Treatment := Accept_Alternative_Open;
  1140.       end if;
  1141.  
  1142.       --  Do rendezvous
  1143.  
  1144.       return Treatment;
  1145.  
  1146.    end Test_Selective_Wait;
  1147.  
  1148.    --------------------
  1149.    -- Selective_Wait --
  1150.    --------------------
  1151.  
  1152.    procedure Selective_Wait
  1153.      (Open_Accepts : Accept_List_Access;
  1154.       Select_Mode  : Select_Modes;
  1155.       Uninterpreted_Data    : out System.Address;
  1156.       Index        : out Select_Index)
  1157.    is
  1158.       Acceptor  : constant Utilities.ATCB_Ptr := ID_To_ATCB (Self);
  1159.       Treatment : Select_Treatment;
  1160.       I_Result  : Integer;
  1161.       Error     : Boolean;
  1162.  
  1163.    begin
  1164.       Defer_Abortion;
  1165.       Write_Lock (Acceptor.L, Error);
  1166.  
  1167.       --  If someone is completing this task, it must be because they plan
  1168.       --  to abort it.  This task should not try to access its pending entry
  1169.       --  calls or queues in this case, as they are being emptied.  Wait for
  1170.       --  abortion to kill us.
  1171.  
  1172.       if Acceptor.Stage >= Utilities.Completing then
  1173.  
  1174.          loop
  1175.             if Acceptor.Pending_Action then
  1176.                if Acceptor.Pending_Priority_Change then
  1177.                   Abortion.Change_Base_Priority (Acceptor);
  1178.                end if;
  1179.  
  1180.                exit when
  1181.                   Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level;
  1182.                Acceptor.Pending_Action := False;
  1183.             end if;
  1184.             Cond_Wait (Acceptor.Cond, Acceptor.L);
  1185.          end loop;
  1186.  
  1187.          Undefer_Abortion;
  1188.          Assert (False, "Continuing execution after being aborted.");
  1189.       end if;
  1190.  
  1191.       Treatment := Test_Selective_Wait (Acceptor, Open_Accepts, Select_Mode);
  1192.  
  1193.       case Treatment is
  1194.  
  1195.       when Accept_Alternative_Selected =>
  1196.  
  1197.          --  Ready to rendezvous already
  1198.  
  1199.          Uninterpreted_Data := Acceptor.Call.Uninterpreted_Data;
  1200.  
  1201.       when Accept_Alternative_Completed =>
  1202.  
  1203.          --  Rendezvous is over
  1204.  
  1205.          null;
  1206.  
  1207.       when Accept_Alternative_Open =>
  1208.  
  1209.          --  Wait for caller.
  1210.  
  1211.          Acceptor.Open_Accepts := Open_Accepts;
  1212.  
  1213.          Acceptor.Accepting := Utilities.Select_Wait;
  1214.          Acceptor.Suspended_Abortably := True;
  1215.  
  1216.          while Acceptor.Accepting /= Utilities.Not_Accepting
  1217.          loop
  1218.             if Acceptor.Pending_Action then
  1219.                if Acceptor.Pending_Priority_Change then
  1220.                   Abortion.Change_Base_Priority (Acceptor);
  1221.                end if;
  1222.  
  1223.                exit when
  1224.                   Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level;
  1225.                Acceptor.Pending_Action := False;
  1226.             end if;
  1227.             Cond_Wait (Acceptor.Cond, Acceptor.L);
  1228.          end loop;
  1229.  
  1230.          Acceptor.Suspended_Abortably := False;
  1231.  
  1232.          if Acceptor.Pending_ATC_Level >= Acceptor.ATC_Nesting_Level and then
  1233.           not Open_Accepts (Acceptor.Chosen_Index).Null_Body then
  1234.             Uninterpreted_Data := Acceptor.Call.Uninterpreted_Data;
  1235.          end if;
  1236.  
  1237.          --  Acceptor.Call should already be updated by the Caller if
  1238.          --  not aborted.
  1239.  
  1240.       when Else_Selected =>
  1241.          Acceptor.Accepting := Utilities.Not_Accepting;
  1242.  
  1243.       when Terminate_Selected =>
  1244.  
  1245.          --  Terminate alternative is open
  1246.  
  1247.          Acceptor.Open_Accepts := Open_Accepts;
  1248.  
  1249.          Acceptor.Accepting := Utilities.Select_Wait;
  1250.  
  1251.          --  We need to check if a signal is pending on an open interrupt
  1252.          --  entry. Otherwise this task would become passive (since terminate
  1253.          --  alternative is open) and, if none of the siblings are active
  1254.          --  anymore, the task could not wake up anymore, even though a
  1255.          --  signal might be pending on an open interrupt entry.
  1256.  
  1257.          Unlock (Acceptor.L);
  1258.          Utilities.Terminate_Alternative;
  1259.  
  1260.          --  Wait for normal entry call or termination
  1261.  
  1262.          --  consider letting Terminate_Alternative assume mutex L
  1263.          --  is already locked, and return with it locked, so
  1264.          --  this code could be simplified???
  1265.  
  1266.          --  No return here if Acceptor completes, otherwise
  1267.          --  Acceptor.Call should already be updated by the Caller
  1268.  
  1269.          Index := Acceptor.Chosen_Index;
  1270.          if not Open_Accepts (Acceptor.Chosen_Index).Null_Body then
  1271.             Uninterpreted_Data := Acceptor.Call.Uninterpreted_Data;
  1272.          end if;
  1273.          Undefer_Abortion;
  1274.          return;
  1275.  
  1276.       when No_Alternative_Open =>
  1277.  
  1278.          --  Acceptor.Chosen_Index := No_Rendezvous; => Program_Error ???
  1279.  
  1280.          null;
  1281.  
  1282.       end case;
  1283.  
  1284.       --  Caller has been chosen
  1285.  
  1286.       --  Acceptor.Call should already be updated by the Caller
  1287.  
  1288.       --  Acceptor.Chosen_Index should either be updated by the Caller
  1289.       --  or by Test_Selective_Wait
  1290.  
  1291.       Index := Acceptor.Chosen_Index;
  1292.       Unlock (Acceptor.L);
  1293.       Undefer_Abortion;
  1294.  
  1295.       --  Start rendezvous
  1296.  
  1297.    end Selective_Wait;
  1298.  
  1299.    ----------------
  1300.    -- Task_Count --
  1301.    ----------------
  1302.  
  1303.    function Task_Count (E : Task_Entry_Index) return Natural is
  1304.       T            : constant Utilities.ATCB_Ptr := ID_To_ATCB (Self);
  1305.       Return_Count : Natural;
  1306.       Error        : Boolean;
  1307.  
  1308.    begin
  1309.       Write_Lock (T.L, Error);
  1310.       Return_Count := Count_Waiting (T.Entry_Queues (E));
  1311.       Unlock (T.L);
  1312.       return Return_Count;
  1313.    end Task_Count;
  1314.  
  1315.    --------------
  1316.    -- Callable --
  1317.    --------------
  1318.  
  1319.    function Callable (T : Task_ID) return Boolean is
  1320.    begin
  1321.       return     ID_To_ATCB (T).Stage < Utilities.Complete
  1322.         and then ID_To_ATCB (T).Pending_ATC_Level > ATC_Level_Base'First;
  1323.    end Callable;
  1324.  
  1325. end System.Tasking.Rendezvous;
  1326.